home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tpsqapi1.zip / $ZZAPTMP.ZIP / DISPTXT.INC next >
Text File  |  1991-12-31  |  4KB  |  135 lines
  1. (*
  2.  
  3. This is included by SQDEMO.PAS. It allows viewing of squish mail
  4. but can by used for viewing and standard fido message txt.
  5.  
  6. *)
  7.  
  8. Procedure Display_Text(
  9.                                 var fv : file;
  10.                                  bsize : longint;
  11.                             ShowRaw    : Boolean;
  12.                             ShowKludge : Boolean;
  13.                             ShowSeenBy : Boolean;
  14.                              var bread : longint
  15.                            );
  16. type buffertype = array[0..maxint] of byte;
  17. var
  18.     buf     : ^buffertype;
  19.     p       : longint;
  20.     b       : byte;
  21.     s       : string;
  22.     clines  : word;
  23.     klen    : word;
  24.     ok      : boolean;
  25.     asize   : word;
  26.  
  27.     procedure writeit(var s : string);
  28.       begin
  29.        if (Not ShowSeenBy) and (copy(s,1,9) = 'SEEN-BY: ') then
  30.           begin
  31.            s := '';
  32.            exit;
  33.           end;
  34.        writeln(s);
  35.        inc(clines);
  36.        if (clines mod 18) = 0 then
  37.           begin
  38.            write('<<MORE>>');
  39.            if readkey = #0 then;
  40.            writeln;
  41.           end;
  42.        s := '';
  43.       end;
  44.  
  45.  
  46.  begin
  47.  
  48.    Textcolor(cyan);
  49.    GetMem(buf,Bsize);
  50.    BlockRead(fv,buf^,Bsize,asize);
  51.    bsize := asize;
  52.  
  53.  
  54.    p         := 0;   (* STARTING BYTE  OF MESSAGE CONTENT *)
  55.    s         := '';
  56.    clines    := 0;
  57.    klen      := 0;
  58.    ok        := asize > 0;
  59.    fillchar(s,sizeof(s),0);
  60.    while Ok {(p < bsize)} do
  61.      begin
  62.        b := buf^[p];
  63.        case b of
  64.           $00 : begin
  65.                  {p := bsize;}
  66.                  ok := false;
  67.                 end;
  68.           $0D : begin
  69.                   if buf^[p+1] = $0A then inc(p);
  70.                   if buf^[p+1] = $8D then
  71.                      begin
  72.                        inc(p);
  73.                        if buf^[p+1] IN [$0A,$0D] then inc(p); {get lf/cr}
  74.                      end;
  75.                   writeit(s);
  76.                 end;
  77.           $8D : begin
  78.                   if buf^[p+1] IN [$0A,$0D] then inc(p); {get lf/cr}
  79.                   writeit(s);
  80.                  end;
  81.           $0A : begin
  82.                   textcolor(blue);
  83.                   writeit(s);
  84.                 end;
  85.           $01 : begin
  86.                   s := s + chr(b);
  87.                   if Not ShowRaw then
  88.                      begin
  89.                        inc(p);
  90.                        while (buf^[p] <> $00) and (p < bsize) do
  91.                            begin
  92.                               case buf^[p] of
  93.                                $01 : begin
  94.                                        textcolor(red);
  95.                                        klen := klen +length(s);
  96.                                        s := removestring(s,#13#10);
  97.                                        s := removestring(s,#13#10);
  98.                                        if showkludge
  99.                                           then writeit(s)
  100.                                           else s := '';
  101.                                        textcolor(cyan);
  102.                                        s := s + chr(buf^[p]);
  103.                                      end;
  104.                                else s := s + chr(buf^[p]);
  105.                               end;
  106.                               inc(p);
  107.                            end;
  108.                        if s <> '' then
  109.                          begin
  110.                            textcolor(red);
  111.                            klen := klen +length(s);
  112.                            if copy(s,1,5)=^A'PATH' then
  113.                               begin
  114.                                s := removestring(s,#13#10);
  115.                                s := removestring(s,#13#10);
  116.                                ok := false;
  117.                               end;
  118.                            if showkludge
  119.                               then writeit(s)
  120.                               else s := '';
  121.                            textcolor(cyan);
  122.                          end;
  123.                      end;
  124.                 end
  125.           else s := s + chr(b);
  126.         end; {end case}
  127.        inc(p);
  128.      end;
  129.    if s <> '' then writeit(s);
  130.    textcolor(magenta);
  131.    write('<<EOM>>');
  132.    FreeMem(buf,Bsize);
  133.    bread := p;
  134.   end;
  135.